home *** CD-ROM | disk | FTP | other *** search
/ PC Open 101 / PC Open 101 CD 1.bin / CD1 / INTERNET / EMAIL / pop file / setup.exe / POPFile / Module.pm < prev    next >
Encoding:
Perl POD Document  |  2004-09-28  |  25.2 KB  |  888 lines
  1. #----------------------------------------------------------------------------
  2. #
  3. # This is POPFile's top level Module object.
  4. #
  5. # Copyright (c) 2001-2004 John Graham-Cumming
  6. #
  7. #   This file is part of POPFile
  8. #
  9. #   POPFile is free software; you can redistribute it and/or modify
  10. #   it under the terms of the GNU General Public License as published by
  11. #   the Free Software Foundation; either version 2 of the License, or
  12. #   (at your option) any later version.
  13. #
  14. #   POPFile is distributed in the hope that it will be useful,
  15. #   but WITHOUT ANY WARRANTY; without even the implied warranty of
  16. #   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17. #   GNU General Public License for more details.
  18. #
  19. #   You should have received a copy of the GNU General Public License
  20. #   along with POPFile; if not, write to the Free Software
  21. #   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  22. #
  23. #----------------------------------------------------------------------------
  24.  
  25. package POPFile::Module;
  26.  
  27. use strict;
  28. use IO::Select;
  29.  
  30. # ---------------------------------------------------------------------------------------------
  31. #
  32. # This module implements the base class for all POPFile Loadable
  33. # Modules and contains collection of methods that are common to all
  34. # POPFile modules and only selected ones need be overriden by
  35. # subclasses
  36. #
  37. # POPFile is constructed from a collection of classes which all have
  38. # special PUBLIC interface functions:
  39. #
  40. # initialize() - called after the class is created to set default
  41. # values for internal variables and global configuration information
  42. #
  43. # start() - called once all configuration has been read and POPFile is
  44. # ready to start operating
  45. #
  46. # stop()       - called when POPFile is shutting down
  47. #
  48. # service() - called by the main POPFile process to allow a submodule
  49. # to do its own work (this is optional for modules that do not need to
  50. # perform any service)
  51. #
  52. # prefork() - called when a module has requested a fork, but before
  53. # the fork happens
  54. #
  55. # forked() - called when a module has forked the process.  This is
  56. # called within the child process and should be used to clean up
  57. #
  58. # postfork() - called in the parent process to tell it that the fork
  59. # has occurred.  This is like forked but in the parent
  60. #
  61. # reaper() - called when a process has terminated to give a module a
  62. # chance to do whatever clean up is needed
  63. #
  64. # name() - returns a simple name for the module by which other modules
  65. # can get access through the %components hash.  The name returned here
  66. # will be the name used as the key for this module in %components
  67. #
  68. # deliver()    - called by the message queue to deliver a message
  69. #
  70. # The following methods are PROTECTED and should be accessed by sub classes:
  71. #
  72. # log_() - sends a string to the logger
  73. #
  74. # config_() - gets or sets a configuration parameter for this module
  75. #
  76. # mq_post_() - post a message to the central message queue
  77. #
  78. # mq_register_() - register for messages from the message queue
  79. #
  80. # slurp_() - Reads a line up to CR, CRLF or LF
  81. #
  82. # register_configuration_item_() - register a UI configuration item
  83. #
  84. # A note on the naming
  85. #
  86. # A method or variable that ends with an underscore is PROTECTED and
  87. # should not be accessed from outside the class (or subclass; in C++
  88. # its protected), to access a PROTECTED variable you will find an
  89. # equivalent getter/setter method with no underscore.
  90. #
  91. # Truly PRIVATE variables are indicated by a double underscore at the
  92. # end of the name and should not be accessed outside the class without
  93. # going through a getter/setter and may not be directly accessed by a
  94. # subclass.
  95. #
  96. # For example
  97. #
  98. # $c->foo__() is a private method $c->{foo__} is a private variable
  99. # $c->foo_() is a protected method $c->{foo_} is a protected variable
  100. # $c->foo() is a public method that modifies $c->{foo_} it always
  101. # returns the current value of the variable it is referencing and if
  102. # passed a value sets that corresponding variable
  103. #
  104. # ---------------------------------------------------------------------------------------------
  105.  
  106. # This variable is CLASS wide, not OBJECT wide and is used as
  107. # temporary storage for the slurp_ methods below.  It needs to be
  108. # class wide because different objects may call slurp on the same
  109. # handle as the handle gets passed from object to object.
  110.  
  111. my %slurp_data__;
  112.  
  113. #----------------------------------------------------------------------------
  114. # new
  115. #
  116. #   Class new() function, all real work gets done by initialize and
  117. #   the things set up here are more for documentation purposes than
  118. #   anything so that you know that they exists
  119. #
  120. #----------------------------------------------------------------------------
  121. sub new
  122. {
  123.     my $type = shift;
  124.     my $self;
  125.  
  126.     # A reference to the POPFile::Configuration module, every module is
  127.     # able to get configuration information through this, note that it
  128.     # is valid when initialize is called, however, the configuration is not
  129.     # read from disk until after initialize has been called
  130.  
  131.     $self->{configuration__} = 0; # PRIVATE
  132.  
  133.     # A reference to the POPFile::Logger module
  134.  
  135.     $self->{logger__}        = 0; # PRIVATE
  136.  
  137.     # A reference to the POPFile::MQ module
  138.  
  139.     $self->{mq__}            = 0;
  140.  
  141.     # The name of this module
  142.  
  143.     $self->{name__}          = ''; # PRIVATE
  144.  
  145.     # Used to tell any loops to terminate
  146.  
  147.     $self->{alive_}          = 1;
  148.  
  149.     # This is a reference to the pipeready() function in popfile.pl
  150.     # that it used to determine if a pipe is ready for reading in a
  151.     # cross platform way
  152.  
  153.     $self->{pipeready_}      = 0;
  154.  
  155.     # This is a reference to a function (forker) in popfile.pl that
  156.     # performs a fork and informs modules that a fork has occurred
  157.  
  158.     $self->{forker_}         = 0;
  159.  
  160.     return bless $self, $type;
  161. }
  162.  
  163. # ---------------------------------------------------------------------------------------------
  164. #
  165. # initialize
  166. #
  167. # Called to initialize the module, the main task that this function
  168. # should perform is setting up the default values of the configuration
  169. # options for this object.  This is done through the configuration_
  170. # hash value that will point the configuration module.
  171. #
  172. # Note that the configuration is not loaded from disk until after
  173. # every module's initialize has been called, so do not use any of
  174. # these values until start() is called as they may change
  175. #
  176. # The method should return 1 to indicate that it initialized
  177. # correctly, if it returns 0 then POPFile will abort loading
  178. # immediately
  179. #
  180. # ---------------------------------------------------------------------------------------------
  181. sub initialize
  182. {
  183.     my ( $self ) = @_;
  184.  
  185.     return 1;
  186. }
  187.  
  188. # ---------------------------------------------------------------------------------------------
  189. #
  190. # start
  191. #
  192. # Called when all configuration information has been loaded from disk.
  193. #
  194. # The method should return 1 to indicate that it started correctly, if
  195. # it returns 0 then POPFile will abort loading immediately, returns 2
  196. # if everything OK but this module does not want to continue to be
  197. # used.
  198. #
  199. # ---------------------------------------------------------------------------------------------
  200. sub start
  201. {
  202.     my ( $self ) = @_;
  203.  
  204.     return 1;
  205. }
  206.  
  207. # ---------------------------------------------------------------------------------------------
  208. #
  209. # stop
  210. #
  211. # Called when POPFile is closing down, this is the last method that
  212. # will get called before the object is destroyed.  There is not return
  213. # value from stop().
  214. #
  215. # ---------------------------------------------------------------------------------------------
  216. sub stop
  217. {
  218.     my ( $self ) = @_;
  219. }
  220.  
  221. # ---------------------------------------------------------------------------------------------
  222. #
  223. # reaper
  224. #
  225. # Called when a child process terminates somewhere in POPFile.  The
  226. # object should check to see if it was one of its children and do any
  227. # necessary processing by calling waitpid() on any child handles it
  228. # has
  229. #
  230. # There is no return value from this method
  231. #
  232. # ---------------------------------------------------------------------------------------------
  233. sub reaper
  234. {
  235.     my ( $self ) = @_;
  236. }
  237.  
  238. # ---------------------------------------------------------------------------------------------
  239. #
  240. # service
  241. #
  242. # service() is a called periodically to give the module a chance to do
  243. # housekeeping work.
  244. #
  245. # If any problem occurs that requires POPFile to shutdown service()
  246. # should return 0 and the top level process will gracefully terminate
  247. # POPFile including calling all stop() methods.  In normal operation
  248. # return 1.
  249. #
  250. # ---------------------------------------------------------------------------------------------
  251. sub service
  252. {
  253.     my ( $self ) = @_;
  254.  
  255.     return 1;
  256. }
  257.  
  258. # ---------------------------------------------------------------------------------------------
  259. #
  260. # prefork
  261. #
  262. # This is called when some module is about to fork POPFile
  263. #
  264. # There is no return value from this method
  265. #
  266. # ---------------------------------------------------------------------------------------------
  267. sub prefork
  268. {
  269.     my ( $self ) = @_;
  270. }
  271.  
  272. # ---------------------------------------------------------------------------------------------
  273. #
  274. # forked
  275. #
  276. # This is called when some module forks POPFile and is within the
  277. # context of the child process so that this module can close any
  278. # duplicated file handles that are not needed.
  279. #
  280. # $writer The writing end of a pipe that can be used to send up from
  281. #         the child
  282. #
  283. # There is no return value from this method
  284. #
  285. # ---------------------------------------------------------------------------------------------
  286. sub forked
  287. {
  288.     my ( $self, $writer ) = @_;
  289. }
  290.  
  291. # ---------------------------------------------------------------------------------------------
  292. #
  293. # postfork
  294. #
  295. # This is called when some module has just forked POPFile.  It is
  296. # called in the parent process.
  297. #
  298. # $pid The process ID of the new child process $reader The reading end
  299. #      of a pipe that can be used to read messages from the child
  300. #
  301. # There is no return value from this method
  302. #
  303. # ---------------------------------------------------------------------------------------------
  304. sub postfork
  305. {
  306.     my ( $self, $pid, $reader ) = @_;
  307. }
  308.  
  309. # ---------------------------------------------------------------------------------------------
  310. #
  311. # deliver
  312. #
  313. # Called by the message queue to deliver a message
  314. #
  315. # There is no return value from this method
  316. #
  317. # ---------------------------------------------------------------------------------------------
  318. sub deliver
  319. {
  320.     my ( $self, $type, @message ) = @_;
  321. }
  322.  
  323. # ---------------------------------------------------------------------------------------------
  324. #
  325. # log_
  326. #
  327. # Called by a subclass to send a message to the logger, the logged
  328. # message will be prefixed by the name of the module in use
  329. #
  330. # $level             The log level (see POPFile::Logger for details)
  331. # $message           The message to log
  332. #
  333. # There is no return value from this method
  334. #
  335. # ---------------------------------------------------------------------------------------------
  336. sub log_
  337. {
  338.     my ( $self, $level, $message ) = @_;
  339.  
  340.     my ( $package, $file, $line ) = caller;
  341.     $self->{logger__}->debug( $level, $self->{name__} . ": $line: " .
  342.         $message );
  343. }
  344.  
  345. # ---------------------------------------------------------------------------------------------
  346. #
  347. # config_
  348. #
  349. # Called by a subclass to get or set a configuration parameter
  350. #
  351. # $name              The name of the parameter (e.g. 'port')
  352. # $value             (optional) The value to set
  353. #
  354. # If called with just a $name then config_() will return the current value
  355. # of the configuration parameter.
  356. #
  357. # ---------------------------------------------------------------------------------------------
  358. sub config_
  359. {
  360.     my ( $self, $name, $value ) = @_;
  361.  
  362.     return $self->module_config_( $self->{name__}, $name, $value );
  363. }
  364.  
  365. # ---------------------------------------------------------------------------------------------
  366. #
  367. # mq_post_
  368. #
  369. # Called by a subclass to post a message to the message queue
  370. #
  371. # $type              Type of message to send
  372. # @message           Message to send
  373. #
  374. # ---------------------------------------------------------------------------------------------
  375. sub mq_post_
  376. {
  377.     my ( $self, $type, @message ) = @_;
  378.  
  379.     return $self->{mq__}->post( $type, @message );
  380. }
  381.  
  382. # ---------------------------------------------------------------------------------------------
  383. #
  384. # mq_register_
  385. #
  386. # Called by a subclass to register with the message queue for messages
  387. #
  388. # $type              Type of message to send
  389. # $object            Callback object
  390. #
  391. # ---------------------------------------------------------------------------------------------
  392. sub mq_register_
  393. {
  394.     my ( $self, $type, $object ) = @_;
  395.  
  396.     return $self->{mq__}->register( $type, $object );
  397. }
  398.  
  399. # ---------------------------------------------------------------------------------------------
  400. #
  401. # global_config_
  402. #
  403. # Called by a subclass to get or set a global (i.e. not module
  404. # specific) configuration parameter
  405. #
  406. # $name              The name of the parameter (e.g. 'port')
  407. # $value             (optional) The value to set
  408. #
  409. # If called with just a $name then global_config_() will return the
  410. # current value of the configuration parameter.
  411. #
  412. # ---------------------------------------------------------------------------------------------
  413. sub global_config_
  414. {
  415.     my ( $self, $name, $value ) = @_;
  416.  
  417.     return $self->module_config_( 'GLOBAL', $name, $value );
  418. }
  419.  
  420. # ---------------------------------------------------------------------------------------------
  421. #
  422. # module_config_
  423. #
  424. # Called by a subclass to get or set a module specific configuration parameter
  425. #
  426. # $module The name of the module that owns the parameter (e.g. 'pop3')
  427. # $name   The name of the parameter (e.g. 'port') $value (optional) The
  428. #         value to set
  429. #
  430. # If called with just a $module and $name then module_config_() will
  431. # return the current value of the configuration parameter.
  432. #
  433. # ---------------------------------------------------------------------------------------------
  434. sub module_config_
  435. {
  436.     my ( $self, $module, $name, $value ) = @_;
  437.  
  438.     return $self->{configuration__}->parameter( $module . "_" . $name, $value );
  439. }
  440.  
  441. # ---------------------------------------------------------------------------------------------
  442. #
  443. # register_configuration_item_
  444. #
  445. # Called by a subclass to register a UI element
  446. #
  447. # $type, $name, $templ, $object
  448. #     See register_configuration_item__ in UI::HTML
  449. #
  450. # ---------------------------------------------------------------------------------------------
  451. sub register_configuration_item_
  452. {
  453.     my ( $self, $type, $name, $templ, $object ) = @_;
  454.  
  455.     return $self->mq_post_( 'UIREG', $type, $name, $templ, $object );
  456. }
  457.  
  458. # ---------------------------------------------------------------------------------------------
  459. #
  460. # get_user_path_, get_root_path_
  461. #
  462. # Wrappers for POPFile::Configuration get_user_path and get_root_path
  463. #
  464. # $path              The path to modify
  465. # $sandbox           Set to 1 if this path must be sandboxed (i.e. absolute
  466. #                    paths and paths containing .. are not accepted).
  467. #
  468. # ---------------------------------------------------------------------------------------------
  469. sub get_user_path_
  470. {
  471.     my ( $self, $path, $sandbox ) = @_;
  472.  
  473.     return $self->{configuration__}->get_user_path( $path, $sandbox );
  474. }
  475.  
  476. sub get_root_path_
  477. {
  478.     my ( $self, $path, $sandbox ) = @_;
  479.  
  480.     return $self->{configuration__}->get_root_path( $path, $sandbox );
  481. }
  482.  
  483. # ---------------------------------------------------------------------------------------------
  484. #
  485. # flush_slurp_data__
  486. #
  487. # Helper function for slurp_ that returns an empty string if the slurp
  488. # buffer doesn't contain a complete line, or returns a complete line.
  489. #
  490. # $handle            Handle to read from, which should be in binmode
  491. #
  492. # ---------------------------------------------------------------------------------------------
  493. sub flush_slurp_data__
  494. {
  495.     my ( $self, $handle ) = @_;
  496.  
  497.     # The acceptable line endings are CR, CRLF or LF.  So we look for
  498.     # them using these regexps.
  499.  
  500.     # Look for LF
  501.  
  502.     if ( $slurp_data__{"$handle"}{data} =~ s/^([^\015\012]*\012)// ) {
  503.         return $1;
  504.     }
  505.  
  506.     # Look for CRLF
  507.  
  508.     if ( $slurp_data__{"$handle"}{data} =~ s/^([^\015\012]*\015\012)// ) {
  509.         return $1;
  510.     }
  511.  
  512.     # Look for CR, here we have to be careful because of the fact that
  513.     # the current total buffer could be ending with CR and there could
  514.     # actually be an LF to read, so we check for that situation if we
  515.     # find CR
  516.  
  517.     if ( $slurp_data__{"$handle"}{data} =~ s/^([^\015\012]*\015)// ) {
  518.         my $cr = $1;
  519.  
  520.         # If we have removed everything from the buffer then see if
  521.         # there's another character available to read, if there is
  522.         # then get it and check to see if it is LF (in which case this
  523.         # is a line ending CRLF), otherwise just save it
  524.  
  525.         if ( $slurp_data__{"$handle"}{data} eq '' ) {
  526.  
  527.             # This unpleasant boolean is to handle the case where we
  528.             # are slurping a non-socket stream under Win32
  529.  
  530.             my $can_read;
  531.  
  532.             $can_read = ( ( $handle !~ /socket/i ) && ( $^O eq 'MSWin32' ) );
  533.  
  534.             if ( !$can_read ) {
  535.                 if ( $handle =~ /ssl/i ) {
  536.                     # If using SSL, check internal buffer of OpenSSL first.
  537.                     $can_read = ( $handle->pending() > 0 );
  538.                 }
  539.                 if ( !$can_read ) {
  540.                     $can_read = defined( $slurp_data__{"$handle"}{select}->can_read( $self->global_config_( 'timeout' ) ) );
  541.                 }
  542.             }
  543.  
  544.             if ( $can_read ) {
  545.  
  546.                 my $c;
  547.                 my $retcode = sysread( $handle, $c, 1 );
  548.                 if ( $retcode == 1 ) {
  549.                     if ( $c eq "\012" ) {
  550.                         $cr .= $c;
  551.                     } else {
  552.                         $slurp_data__{"$handle"}{data} = $c;
  553.             }
  554.         }
  555.         }
  556.     }
  557.  
  558.         return $cr;
  559.     }
  560.  
  561.     return '';
  562. }
  563.  
  564. # ---------------------------------------------------------------------------------------------
  565. #
  566. # slurp_data_size__
  567. #
  568. # $handle          A connection handle previously used with slurp_
  569. #
  570. # Returns the length of data currently buffered for the passed in handle
  571. #
  572. # ---------------------------------------------------------------------------------------------
  573.  
  574. sub slurp_data_size__
  575. {
  576.     my ( $self, $handle ) = @_;
  577.  
  578.     return defined($slurp_data__{"$handle"}{data})?length($slurp_data__{"$handle"}{data}):0;
  579. }
  580.  
  581. # ---------------------------------------------------------------------------------------------
  582. #
  583. # slurp_buffer_
  584. #
  585. # $handle                     Handle to read from, which should be in binmode
  586. # $length                     The amount of data to read
  587. #
  588. # Reads up to $length bytes from $handle and returns it, if there is nothing
  589. # to return because the buffer is empty and the handle is at eof then this
  590. # will return undef
  591. #
  592. # ---------------------------------------------------------------------------------------------
  593.  
  594. sub slurp_buffer_
  595. {
  596.     my ( $self, $handle, $length ) = @_;
  597.  
  598.     while ( $self->slurp_data_size__( $handle ) < $length ) {
  599.         my $c;
  600.         if ( sysread( $handle, $c, $length ) > 0 ) {
  601.             $slurp_data__{"$handle"}{data} .= $c;
  602.         } else {
  603.             last;
  604.         }
  605.     }
  606.  
  607.     my $result = '';
  608.  
  609.     if ( $self->slurp_data_size__( $handle ) < $length ) {
  610.         $result = $slurp_data__{"$handle"}{data};
  611.         $slurp_data__{"$handle"}{data} = '';
  612.     } else {
  613.         $result = substr( $slurp_data__{"$handle"}{data}, 0, $length );
  614.         $slurp_data__{"$handle"}{data} =
  615.             substr( $slurp_data__{"$handle"}{data}, $length );
  616.     }
  617.  
  618.     return ($result ne '')?$result:undef;
  619. }
  620.  
  621. # ---------------------------------------------------------------------------------------------
  622. #
  623. # slurp_
  624. #
  625. # A replacement for Perl's <> operator on a handle that reads a line
  626. # until CR, CRLF or LF is encountered.  Returns the line if read (with
  627. # the CRs and LFs), or undef if at the EOF, blocks waiting for
  628. # something to read.
  629. #
  630. # IMPORTANT NOTE: If you don't read to the end of the stream using
  631. # slurp_ then there may be a small memory leak caused by slurp_'s
  632. # buffering of data in the Module's hash.  To flush it make a call to
  633. # slurp_ when you know that the handle is at the end of the stream, or
  634. # call done_slurp_ on the handle.
  635. #
  636. # $handle            Handle to read from, which should be in binmode
  637. #
  638. # ---------------------------------------------------------------------------------------------
  639. sub slurp_
  640. {
  641.     my ( $self, $handle ) = @_;
  642.  
  643.     if ( !defined( $slurp_data__{"$handle"}{data} ) ) {
  644.         $slurp_data__{"$handle"}{select} = new IO::Select( $handle );
  645.         $slurp_data__{"$handle"}{data}   = '';
  646.     }
  647.  
  648.     my $result = $self->flush_slurp_data__( $handle );
  649.  
  650.     if ( $result ne '' ) {
  651.         return $result;
  652.     }
  653.  
  654.     my $c;
  655.  
  656.     while ( sysread( $handle, $c, 160 ) > 0 ) {
  657.         $slurp_data__{"$handle"}{data} .= $c;
  658.  
  659.         $self->log_( 2, "Read slurp data $c" );
  660.  
  661.         $result = $self->flush_slurp_data__( $handle );
  662.  
  663.         if ( $result ne '' ) {
  664.             return $result;
  665.         }
  666.     }
  667.  
  668.     # If we get here with something in line then the file ends without any
  669.     # CRLF so return the line, otherwise we are reading at the end of the
  670.     # stream/file so return undef
  671.  
  672.     my $remaining = $slurp_data__{"$handle"}{data};
  673.     $self->done_slurp_( $handle );
  674.  
  675.     if ( $remaining eq '' ) {
  676.         return undef;
  677.     } else {
  678.         return $remaining;
  679.     }
  680. }
  681.  
  682. # ---------------------------------------------------------------------------------------------
  683. #
  684. # done_slurp_
  685. #
  686. # Call this when have finished calling slurp_ on a handle and need to
  687. # clean up temporary buffer space used by slurp_
  688. #
  689. # ---------------------------------------------------------------------------------------------
  690.  
  691. sub done_slurp_
  692. {
  693.     my ( $self, $handle ) = @_;
  694.  
  695.     delete $slurp_data__{"$handle"}{select};
  696.     delete $slurp_data__{"$handle"}{data};
  697.     delete $slurp_data__{"$handle"};
  698. }
  699.  
  700. # ---------------------------------------------------------------------------------------------
  701. #
  702. # flush_extra_ - Read extra data from the mail server and send to
  703. # client, this is to handle POP servers that just send data when they
  704. # shouldn't.  I've seen one that sends debug messages!
  705. #
  706. # Returns the extra data flushed
  707. #
  708. # $mail        The handle of the real mail server
  709. # $client      The mail client talking to us
  710. # $discard     If 1 then the extra output is discarded
  711. #
  712. # ---------------------------------------------------------------------------------------------
  713. sub flush_extra_
  714. {
  715.     my ( $self, $mail, $client, $discard ) = @_;
  716.  
  717.     $discard = 0 if ( !defined( $discard ) );
  718.  
  719.     # If slurp has any data, we want it
  720.  
  721.     if ( $self->slurp_data_size__($mail) ) {
  722.  
  723.         print $client $slurp_data__{"$mail"}{data} if ( $discard != 1 );
  724.         $slurp_data__{"$mail"}{data} = '';
  725.     }
  726.  
  727.     # Do we always attempt to read?
  728.  
  729.     my $always_read = 0;
  730.     my $selector;
  731.  
  732.     if (($^O eq 'MSWin32') && !($mail =~ /socket/i) ) {
  733.  
  734.         # select only works reliably on IO::Sockets in Win32, so we
  735.         # always read files on MSWin32 (sysread returns 0 for eof)
  736.  
  737.         $always_read = 1; # PROFILE PLATFORM START MSWin32
  738.                           # PROFILE PLATFORM STOP
  739.     } else {
  740.  
  741.         # in all other cases, a selector is used to decide whether to read
  742.  
  743.         $selector    = new IO::Select( $mail );
  744.         $always_read = 0;
  745.     }
  746.  
  747.     my $ready;
  748.  
  749.     my $buf        = '';
  750.     my $full_buf   = '';
  751.     my $max_length = 8192;
  752.     my $n;
  753.  
  754.     while ( $always_read || defined( $selector->can_read(0.01) ) ) {
  755.         $n = sysread( $mail, $buf, $max_length, length $buf );
  756.  
  757.         if ( $n > 0 ) {
  758.             print $client $buf if ( $discard != 1 );
  759.             $full_buf .= $buf;
  760.         } else {
  761.             if ($n == 0) {
  762.                 last;
  763.             }
  764.         }
  765.     }
  766.  
  767.    return $full_buf;
  768. }
  769.  
  770. # GETTER/SETTER methods.  Note that I do not expect documentation of
  771. # these unless they are non-trivial since the documentation would be a
  772. # waste of space
  773. #
  774. # The only thing to note is the idiom used, stick to that and there's
  775. # no need to document these
  776. #
  777. #   sub foo
  778. #   {
  779. #       my ( $self, $value ) = @_;
  780. #
  781. #       if ( defined( $value ) ) {
  782. #           $self->{foo_} = $value;
  783. #       }
  784. #
  785. #       return $self->{foo_};
  786. #   }
  787. #
  788. # This method access the foo_ variable for reading or writing,
  789. # $c->foo() read foo_ and $c->foo( 'foo' ) writes foo_
  790.  
  791. sub mq
  792. {
  793.     my ( $self, $value ) = @_;
  794.  
  795.     if ( defined( $value ) ) {
  796.         $self->{mq__} = $value;
  797.     }
  798.  
  799.     return $self->{mq__};
  800. }
  801.  
  802. sub configuration
  803. {
  804.     my ( $self, $value ) = @_;
  805.  
  806.     if ( defined( $value ) ) {
  807.         $self->{configuration__} = $value;
  808.     }
  809.  
  810.     return $self->{configuration__};
  811. }
  812.  
  813. sub forker
  814. {
  815.     my ( $self, $value ) = @_;
  816.  
  817.     if ( defined( $value ) ) {
  818.         $self->{forker_} = $value;
  819.     }
  820.  
  821.     return $self->{forker_};
  822. }
  823.  
  824. sub logger
  825. {
  826.     my ( $self, $value ) = @_;
  827.  
  828.     if ( defined( $value ) ) {
  829.         $self->{logger__} = $value;
  830.     }
  831.  
  832.     return $self->{logger__};
  833. }
  834.  
  835. sub pipeready
  836. {
  837.     my ( $self, $value ) = @_;
  838.  
  839.     if ( defined( $value ) ) {
  840.         $self->{pipeready_} = $value;
  841.     }
  842.  
  843.     return $self->{pipeready_};
  844. }
  845.  
  846. sub alive
  847. {
  848.     my ( $self, $value ) = @_;
  849.  
  850.     if ( defined( $value ) ) {
  851.         $self->{alive_} = $value;
  852.     }
  853.  
  854.     return $self->{alive_};
  855. }
  856.  
  857. sub name
  858. {
  859.     my ( $self, $value ) = @_;
  860.  
  861.     if ( defined( $value ) ) {
  862.         $self->{name__} = $value;
  863.     }
  864.  
  865.     return $self->{name__};
  866. }
  867.  
  868. sub version
  869. {
  870.     my ( $self, $value ) = @_;
  871.  
  872.     if ( defined( $value ) ) {
  873.         $self->{version_} = $value;
  874.     }
  875.  
  876.     return $self->{version_};
  877. }
  878.  
  879. sub last_ten_log_entries
  880. {
  881.     my ( $self ) = @_;
  882.  
  883.     return $self->{logger__}->last_ten();
  884. }
  885.  
  886. 1;
  887.  
  888.